home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / aux-macros.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  4KB  |  213 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: aux-macros.em
  4. ;; Date: Mon Aug  3 13:36:43 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule aux-macros
  11.         (standard0
  12.          list-fns
  13.          
  14.          )
  15.         ()
  16.        
  17. (defmacro break forms
  18.   `(@break-cont@ (progn ,@forms)))
  19.  
  20. (defmacro continue ()
  21.   `(@continue-cont@ '(() t)))
  22.  
  23. ;(defmacro while (pred . forms)
  24. ;  `(let/cc @break-cont@
  25. ;       (map-while (lambda () ,@forms)
  26. ;              (lambda () ,pred)
  27. ;              ())))
  28.  
  29. (defmacro while (pred . forms)
  30.     `(let/cc @break-cont@
  31.        (map-while (lambda (@continue-cont@) ,@forms)
  32.                   (lambda () ,pred)
  33.                   ())))
  34.  
  35. ;(defun map-while (ff pf val)
  36. ;  (labels ((mwc  (val)
  37. ;         (if (pf)
  38. ;             (mwc (ff))
  39. ;           (cons val ()))))
  40. ;      (let ((ans (mwc val)))
  41. ;        (car ans))))
  42.  
  43.  
  44. (defun map-while (ff pf val)
  45.   (let ((ans (let/cc cc (map-while-cont ff pf cc val))))
  46.     (if (cdr ans)
  47.     (map-while ff pf val)
  48.       (car ans))))
  49.  
  50. (defun map-while-cont (ff pf cc val)
  51.   (if (pf)
  52.       (map-while-cont ff pf cc (ff cc))
  53.     (cons val ())))
  54.  
  55. (defmacro docdr (var arglis . body)
  56.   `(when (not (null ,arglis))
  57.      (let ((,var  ,arglis)
  58.            (rest (cdr ,arglis)))
  59.        (while ,var
  60.         (when ,var
  61.           ,@body
  62.           (if rest
  63.               (progn
  64.             (setq ,var  rest)
  65.             (setq rest (cdr rest)))
  66.             (setq ,var nil)))))))
  67.  
  68. (export docdr)
  69.  
  70. (defmacro docollect (var arg-lis . body)
  71.   `(when (not (null ,arg-lis))
  72.      (let ((,var (car ,arg-lis))
  73.            (rest (cdr ,arg-lis))
  74.            (new-lis nil))
  75.        (while ,var
  76.         (when ,var
  77.           (setq new-lis  (append new-lis (list (progn ,@body))))
  78.           (if rest
  79.               (progn
  80.             (setq ,var (car rest))
  81.             (setq rest (cdr rest)))
  82.             (setq ,var nil))))
  83.        new-lis)))
  84.  
  85. (export docollect)
  86.  
  87. (defmacro docollect-unique (var arg-lis . body)
  88.   `(when (not (null ,arg-lis))
  89.      (let ((,var (car ,arg-lis))
  90.            (rest (cdr ,arg-lis))
  91.            (new-lis nil)
  92.            (temp nil))
  93.        (while ,var
  94.          (when (not (memq (setq temp (progn ,@body)) new-lis))
  95.             (setq new-lis  (append new-lis (list temp))))
  96.           (if rest
  97.               (progn
  98.             (setq ,var (car rest))
  99.             (setq rest (cdr rest)))
  100.             (setq ,var nil)))
  101.        new-lis)))
  102.  
  103. (export docollect-unique)
  104.  
  105. (defmacro dotimes (var num . body)
  106.   `(let ((,var 1))
  107.      (while (or (< ,var ,num) (= ,var ,num))
  108.         ,@body
  109.         (setq ,var (+ ,var 1)))))
  110.  
  111.  
  112. (export dotimes)
  113.   ;; List macros...
  114.  
  115. (defmacro push (val st) `(setq ,st (cons ,val ,st)))
  116.  
  117.  
  118. (defmacro pop (st) `(let ((val (car ,st)))
  119.             (setq ,st (cdr ,st))
  120.             val))
  121. (export push pop)
  122.  
  123. (defmacro incf (arg)
  124.   `(setq ,arg (+ 1 ,arg)))
  125.  
  126. (export incf)
  127.  
  128. (defmacro decf (arg)
  129.   `(setq ,arg (- ,arg 1)))
  130.  
  131. (export decf)
  132.  
  133. (defmacro trap (value . forms)
  134.   `(let/cc escape
  135.        (with-handler (lambda (a b) (escape ,value)) ,@forms)))
  136.  
  137. (export trap)
  138.  
  139. (defmacro multiple-setq forms
  140.     (if forms
  141.       `(progn 
  142.          (setq ,(car forms) ,(cadr forms))
  143.          (multiple-setq ,@(cddr forms)))
  144.       `(progn)))
  145.  
  146. (export multiple-setq)
  147.  
  148. (defmacro dolist (var arglist . body)
  149.   `(mapc (lambda (,var) ,@body) ,arglist))
  150.  
  151. (export dolist)
  152.  
  153. (defmacro do* (control test-result . body)
  154.     (let ((decl nil) (label (gensym)) (vl nil) (step nil)
  155.           (test (car test-result))
  156.           (result (cdr test-result)))
  157.  
  158.  
  159.       (mapc (lambda (c)
  160.           (when (symbolp c) (setq c (list c)))
  161.           (push (list (car c) (cadr c)) vl)
  162.           (unless (not (consp (cddr c)))
  163.               (push (car c) step)
  164.               (push (caddr c) step)))
  165.           control)
  166.       
  167.       `(let* ,(reverse vl)
  168. ;     ,@decl
  169.      (while (not ,test) 
  170.        (progn ,@body)
  171.        (multiple-setq ,@(reverse step)))
  172.      (progn ,@result))))
  173.  
  174. (export do*)  
  175.  
  176.  
  177.  
  178.  
  179.  
  180. (defun sll-signature (ll)
  181.     (let ((cl-name nil))
  182.       (cond ((not (consp ll)) nil)
  183.             ((consp (car ll))
  184.          (cons (cadar ll) (sll-signature (cdr ll))))
  185.         (t (cons 'object (sll-signature (cdr ll)))))))
  186.  
  187.  
  188. (defun sll-formals (ll)
  189.     (cond ((not (consp ll)) nil)
  190.           ((consp (car ll)) (cons (caar ll) (sll-formals (cdr ll))))
  191.           (t (cons (car ll) (sll-formals (cdr ll))))))
  192.  
  193. (defmacro make-method (name sll . body)
  194.   `(let* ((k nil)
  195.       (method (make-instance (generic-function-method-class ,name)
  196.             'signature (list ,@(sll-signature sll))
  197.             'function
  198.               (lambda (***method-status-handle***
  199.                    ***method-args-handle***
  200.                    ,@(sll-formals sll)) 
  201.                 ,@body))))
  202.      (add-method ,name method)
  203.     method))
  204.  
  205.  
  206.  
  207.  
  208.  
  209. (export make-method break continue while map-while map-while-cont)
  210.  
  211.       ;; end module
  212.       )
  213.